home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / package.d < prev    next >
Text File  |  1987-06-03  |  20KB  |  967 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     package.d
  9. */
  10.  
  11. #include "include.h"
  12.  
  13. #define    HASHCOEF    12345        /*  hashing coefficient  */
  14.  
  15. object lisp_package;
  16. object user_package;
  17. object keyword_package;
  18. object system_package;
  19.  
  20. object Vpackage;        /*  *package*  */
  21.  
  22. object Kinternal;
  23. object Kexternal;
  24. object Kinherited;
  25. object Knicknames;
  26. object Kuse;
  27.  
  28. int intern_flag;
  29.  
  30. #define    INTERNAL    1
  31. #define    EXTERNAL    2
  32. #define    INHERITED    3
  33.  
  34. object uninterned_list;
  35.  
  36. bool
  37. member_string_equal(x, l)
  38. object x, l;
  39. {
  40.     for (;  type_of(l) == t_cons;  l = l->c.c_cdr)
  41.         if (string_equal(x, l->c.c_car))
  42.             return(TRUE);
  43.     return(FALSE);
  44. }
  45.  
  46. /*
  47.     Make_package(n, ns, ul) makes a package with name n,
  48.     which must be a string or a symbol,
  49.     and nicknames ns, which must be a list of strings or symbols,
  50.     and uses packages in list ul, which must be a list of packages
  51.     or package names i.e. strings or symbols.
  52. */
  53. object
  54. make_package(n, ns, ul)
  55. object n, ns, ul;
  56. {
  57.     object x, y;
  58.     int i;
  59.     vs_mark;
  60.  
  61.     if (type_of(n) == t_symbol) {
  62.         vs_push(alloc_simple_string(n->s.s_fillp));
  63.         vs_head->st.st_self = n->s.s_self;
  64.         n = vs_head;
  65.     }
  66.     if (find_package(n) != Cnil)
  67.         package_already(n);
  68.     x = alloc_object(t_package);
  69.     x->p.p_name = n;
  70.     x->p.p_nicknames = Cnil;
  71.     x->p.p_shadowings = Cnil;
  72.     x->p.p_uselist = Cnil;
  73.     x->p.p_usedbylist = Cnil;
  74.     x->p.p_internal = NULL;
  75.     x->p.p_external = NULL;
  76.     vs_push(x);
  77.     for (;  !endp(ns);  ns = ns->c.c_cdr) {
  78.         n = ns->c.c_car;
  79.         if (type_of(n) == t_symbol) {
  80.             vs_push(alloc_simple_string(n->s.s_fillp));
  81.             vs_head->st.st_self = n->s.s_self;
  82.             n = vs_head;
  83.         }
  84.         if (find_package(n) != Cnil) {
  85.             vs_reset;
  86.             package_already(n);
  87.         }
  88.         x->p.p_nicknames = make_cons(n, x->p.p_nicknames);
  89.     }
  90.     for (;  !endp(ul);  ul = ul->c.c_cdr) {
  91.         if (type_of(ul->c.c_car) == t_package)
  92.             y = ul->c.c_car;
  93.         else {
  94.             y = find_package(ul->c.c_car);
  95.             if (y == Cnil)
  96.                 no_package(ul->c.c_car);
  97.         }
  98.         x->p.p_uselist = make_cons(y, x->p.p_uselist);
  99.         y->p.p_usedbylist = make_cons(x, y->p.p_usedbylist);
  100.     }
  101.     x->p.p_internal
  102.     = (object *)alloc_contblock(PHTABSIZE * sizeof(object));
  103.     for (i = 0;  i < PHTABSIZE;  i++)
  104.         x->p.p_internal[i] = Cnil;
  105.     x->p.p_external
  106.     = (object *)alloc_contblock(PHTABSIZE * sizeof(object));
  107.     for (i = 0;  i < PHTABSIZE;  i++)
  108.         x->p.p_external[i] = Cnil;
  109.     x->p.p_link = pack_pointer;
  110.     pack_pointer = &(x->p);
  111.     vs_reset;
  112.     return(x);
  113. }
  114.  
  115. object
  116. in_package(n, ns, ul)
  117. object n, ns, ul;
  118. {
  119.     object x, y;
  120.     int i;
  121.     vs_mark;
  122.  
  123.     x = find_package(n);
  124.     if (x == Cnil) {
  125.         x = make_package(n, ns, ul);
  126.         goto L;
  127.     }
  128.     for (;  !endp(ns);  ns = ns->c.c_cdr) {
  129.         n = ns->c.c_car;
  130.         if (type_of(n) == t_symbol) {
  131.             vs_push(alloc_simple_string(n->s.s_fillp));
  132.             vs_head->st.st_self = n->s.s_self;
  133.             n = vs_head;
  134.         }
  135.         y = find_package(n);
  136.         if (x == y)
  137.             continue;
  138.         if (y != Cnil)
  139.             package_already(n);
  140.         x->p.p_nicknames = make_cons(n, x->p.p_nicknames);
  141.     }
  142.     for (;  !endp(ul);  ul = ul->c.c_cdr)
  143.         use_package(ul->c.c_car, x);
  144. L:
  145.     Vpackage->s.s_dbind = x;
  146.     vs_reset;
  147.     return(x);
  148. }
  149.  
  150. object
  151. rename_package(x, n, ns)
  152. object x, n, ns;
  153. {
  154.     object y;
  155.     vs_mark;
  156.  
  157.     if (type_of(n) == t_symbol) {
  158.         vs_push(alloc_simple_string(n->s.s_fillp));
  159.         vs_head->st.st_self = n->s.s_self;
  160.         n = vs_head;
  161.     }
  162.     if (find_package(n) != Cnil)
  163.         package_already(n);
  164.     x->p.p_name = n;
  165.     x->p.p_nicknames = Cnil;
  166.     for (;  !endp(ns);  ns = ns->c.c_cdr) {
  167.         n = ns->c.c_car;
  168.         if (type_of(n) == t_symbol) {
  169.             vs_push(alloc_simple_string(n->s.s_fillp));
  170.             vs_head->st.st_self = n->s.s_self;
  171.             n = vs_head;
  172.         }
  173.         y = find_package(n);
  174.         if (x == y)
  175.             continue;
  176.         if (y != Cnil)
  177.             package_already(n);
  178.         x->p.p_nicknames = make_cons(n, x->p.p_nicknames);
  179.     }
  180.     vs_reset;
  181.     return(x);
  182. }
  183.  
  184. /*
  185.     Find_package(n) seaches for a package with name n,
  186.     which is a string or a symbol.
  187.     If not so, an error is signaled.
  188. */
  189. object
  190. find_package(n)
  191. object n;
  192. {
  193.     struct package *p;
  194.  
  195.     if (type_of(n) == t_symbol)
  196.         ;
  197.     else if (type_of(n) != t_string)
  198.         FEwrong_type_argument(TSor_string_symbol, n);
  199.     for (p = pack_pointer;  p != NULL;  p = p->p_link) {
  200.         if (string_equal(p->p_name, n))
  201.             return((object)p);
  202.         if (member_string_equal(n, p->p_nicknames))
  203.             return((object)p);
  204.     }
  205.     return(Cnil);
  206. }
  207.  
  208. object
  209. coerce_to_package(p)
  210. object p;
  211. {
  212.     object pp;
  213.  
  214.     if (type_of(p) == t_package)
  215.         return(p);
  216.     pp = find_package(p);
  217.     if (pp == Cnil)
  218.         no_package(p);
  219.     return(pp);
  220. }
  221.  
  222. object
  223. current_package()
  224. {
  225.     object x;
  226.  
  227.     x = symbol_value(Vpackage);
  228.     if (type_of(x) != t_package) {
  229.         Vpackage->s.s_dbind = user_package;
  230.         FEerror("The value of *PACKAGE*, ~S, was not a package.",
  231.             1, x);
  232.     }
  233.     return(x);
  234. }
  235.  
  236. /*
  237.     Pack_hash(st) hashes string st
  238.     and returns the index for a hash table of a package.
  239. */
  240. int
  241. pack_hash(st)
  242. object st;
  243. {
  244.     int h, i;
  245.  
  246.     for (h = 0, i = 0;  i < st->st.st_fillp;  i++)
  247.         h += (st->st.st_self[i] & 0377) * HASHCOEF + 1;
  248.     h &= 0x7fffffff;
  249.     return(h %= PHTABSIZE);
  250. }
  251.  
  252. /*
  253.     Intern(st, p) interns string st in package p.
  254. */
  255. object
  256. intern(st, p)
  257. object st, p;
  258. {
  259.     int j;
  260.     object x, *ip, *ep, l, ul;
  261.     vs_mark;
  262.  
  263.     j = pack_hash(st);
  264.     ip = &p->p.p_internal[j];
  265.     for (l = *ip;  type_of(l) == t_cons;  l = l->c.c_cdr)
  266.         if (string_eq(l->c.c_car, st)) {
  267.             intern_flag = INTERNAL;
  268.             return(l->c.c_car);
  269.         }
  270.     ep = &p->p.p_external[j];
  271.     for (l = *ep;  type_of(l) == t_cons;  l = l->c.c_cdr)
  272.         if (string_eq(l->c.c_car, st)) {
  273.             intern_flag = EXTERNAL;
  274.             return(l->c.c_car);
  275.         }
  276.     for (ul=p->p.p_uselist; type_of(ul)==t_cons; ul=ul->c.c_cdr)
  277.         for (l = ul->c.c_car->p.p_external[j];
  278.              type_of(l) == t_cons;
  279.              l = l->c.c_cdr)
  280.             if (string_eq(l->c.c_car, st)) {
  281.                 intern_flag = INHERITED;
  282.                 return(l->c.c_car);
  283.             }
  284.     x = make_symbol(st);
  285.     vs_push(x);
  286.     if (p == keyword_package) {
  287.         x->s.s_stype = (short)stp_constant;
  288.         x->s.s_dbind = x;
  289.         *ep = make_cons(x, *ep);
  290.         intern_flag = 0;
  291.     } else {
  292.         *ip = make_cons(x, *ip);
  293.         intern_flag = 0;
  294.     }
  295.     if (x->s.s_hpack == Cnil)
  296.         x->s.s_hpack = p;
  297.     vs_reset;
  298.     return(x);
  299. }
  300.  
  301. /*
  302.     Find_symbol(st, p) searches for string st in package p.
  303. */
  304. object
  305. find_symbol(st, p)
  306. object st, p;
  307. {
  308.     int j;
  309.     object *ip, *ep, l, ul;
  310.  
  311.     j = pack_hash(st);
  312.     ip = &p->p.p_internal[j];
  313.     for (l = *ip;  type_of(l) == t_cons;  l = l->c.c_cdr)
  314.         if (string_eq(l->c.c_car, st)) {
  315.             intern_flag = INTERNAL;
  316.             return(l->c.c_car);
  317.         }
  318.     ep = &p->p.p_external[j];
  319.     for (l = *ep;  type_of(l) == t_cons;  l = l->c.c_cdr)
  320.         if (string_eq(l->c.c_car, st)) {
  321.             intern_flag = EXTERNAL;
  322.             return(l->c.c_car);
  323.         }
  324.     for (ul=p->p.p_uselist; type_of(ul)==t_cons; ul=ul->c.c_cdr)
  325.         for (l = ul->c.c_car->p.p_external[j];
  326.              type_of(l) == t_cons;
  327.              l = l->c.c_cdr)
  328.             if (string_eq(l->c.c_car, st)) {
  329.                 intern_flag = INHERITED;
  330.                 return(l->c.c_car);
  331.             }
  332.     intern_flag = 0;
  333.     return(Cnil);
  334. }
  335.  
  336. bool
  337. unintern(s, p)
  338. object s, p;
  339. {
  340.     object x, y, l, *lp;
  341.     int j;
  342.  
  343.     j = pack_hash(s);
  344.     x = find_symbol(s, p);
  345.     if (intern_flag == INTERNAL && s == x) {
  346.         lp = &p->p.p_internal[j];
  347.         if (member_eq(s, p->p.p_shadowings))
  348.             goto L;
  349.         goto UNINTERN;
  350.     }
  351.     if (intern_flag == EXTERNAL && s == x) {
  352.         lp = &p->p.p_external[j];
  353.         if (member_eq(s, p->p.p_shadowings))
  354.             goto L;
  355.         goto UNINTERN;
  356.     }
  357.     return(FALSE);
  358.  
  359. L:
  360.     x = OBJNULL;
  361.     for (l = p->p.p_uselist; type_of(l) == t_cons; l = l->c.c_cdr) {
  362.         y = find_symbol(s, l->c.c_car);
  363.         if (intern_flag == EXTERNAL) {
  364.             if (x == OBJNULL)
  365.                 x = y;
  366.             else if (x != y)
  367. FEerror("Cannot unintern the shadowing symbol ~S~%\
  368. from ~S,~%\
  369. because ~S and ~S will cause~%\
  370. a name conflict.", 4, s, p, x, y);
  371.         }
  372.     }
  373.     delete_eq(s, &p->p.p_shadowings);
  374.  
  375. UNINTERN:
  376.     delete_eq(s, lp);
  377.     if (s->s.s_hpack == p)
  378.         s->s.s_hpack = Cnil;
  379.     if ((enum stype)s->s.s_stype != stp_ordinary)
  380.         uninterned_list = make_cons(s, uninterned_list);
  381.     return(TRUE);
  382. }
  383.  
  384. export(s, p)
  385. object s, p;
  386. {
  387.     object x;
  388.     int j;
  389.     object *ep, *ip, l;
  390.  
  391. BEGIN:
  392.     ip = NULL;
  393.     j = pack_hash(s);
  394.     x = find_symbol(s, p);
  395.     if (intern_flag) {
  396.         if (x != s) {
  397.             import(s, p);    /*  signals an error  */
  398.             goto BEGIN;
  399.         }
  400.         if (intern_flag == INTERNAL)
  401.             ip = &p->p.p_internal[j];
  402.         else if (intern_flag == EXTERNAL)
  403.             return;
  404.     } else
  405.         FEerror("The symbol ~S is not accessible from ~S.", 2,
  406.             s, p);
  407.     for (l = p->p.p_usedbylist;
  408.          type_of(l) == t_cons;
  409.          l = l->c.c_cdr) {
  410.         x = find_symbol(s, l->c.c_car);
  411.         if (intern_flag && s != x &&
  412.             !member_eq(x, l->c.c_car->p.p_shadowings))
  413. FEerror("Cannot export the symbol ~S~%\
  414. from ~S,~%\
  415. because it will cause a name conflict~%\
  416. in ~S.", 3, s, p, l->c.c_car);
  417.     }
  418.     if (ip != NULL)
  419.         delete_eq(s, ip);
  420.     ep = &p->p.p_external[j];
  421.     *ep = make_cons(s, *ep);
  422. }
  423.  
  424. unexport(s, p)
  425. object s, p;
  426. {
  427.     object x, *ep, *ip;
  428.     int j;
  429.  
  430.     if (p == keyword_package)
  431.         FEerror("Cannot unexport a symbol from the keyword.", 0);
  432.     x = find_symbol(s, p);
  433.     if (intern_flag != EXTERNAL || x != s)
  434. FEerror("Cannot unexport the symbol ~S~%\
  435. from ~S,~%\
  436. because the symbol is not an external symbol~%\
  437. of the package.", 2, s, p);
  438.     j = pack_hash(s);
  439.     ep = &p->p.p_external[j];
  440.     delete_eq(s, ep);
  441.     ip = &p->p.p_internal[j];
  442.     *ip = make_cons(s, *ip);
  443. }
  444.  
  445. import(s, p)
  446. object s, p;
  447. {
  448.     object x;
  449.     int j;
  450.     object *ip, l;
  451.  
  452.     x = find_symbol(s, p);
  453.     if (intern_flag) {
  454.         if (x != s)
  455. FEerror("Cannot import the symbol ~S~%\
  456. from ~S,~%\
  457. because there is already a symbol with the same name~%\
  458. in the package.", 2, s, p);
  459.         if (intern_flag == INTERNAL || intern_flag == EXTERNAL)
  460.             return;
  461.     }
  462.     j = pack_hash(s);
  463.     ip = &p->p.p_internal[j];
  464.     *ip = make_cons(s, *ip);
  465. }
  466.  
  467. shadowing_import(s, p)
  468. object s, p;
  469. {
  470.     object x;
  471.     int j;
  472.     object *ip, l;
  473.  
  474.     x = find_symbol(s, p);
  475.     if (intern_flag && intern_flag != INHERITED) {
  476.         if (x != s)
  477. FEerror("Cannot shadowing-import the symbol ~S~%\
  478. to ~S,~%\
  479. because there is already a symbol with the same name~%\
  480. in the package.", 2, s, p);
  481.         return;
  482.     }
  483.     j = pack_hash(s);
  484.     ip = &p->p.p_internal[j];
  485.     *ip = make_cons(s, *ip);
  486.     p->p.p_shadowings = make_cons(s, p->p.p_shadowings);
  487. }
  488.  
  489. shadow(s, p)
  490. object s, p;
  491. {
  492.     int j;
  493.     object *ip;
  494.  
  495.     find_symbol(s, p);
  496.     if (intern_flag == INTERNAL || intern_flag == EXTERNAL)
  497.         return;
  498.     j = pack_hash(s);
  499.     ip = &p->p.p_internal[j];
  500.     vs_push(make_symbol(s));
  501.     vs_head->s.s_hpack = p;
  502.     *ip = make_cons(vs_head, *ip);
  503.     p->p.p_shadowings = make_cons(vs_head, p->p.p_shadowings);
  504.     vs_pop;
  505. }
  506.  
  507. use_package(x0, p)
  508. object x0, p;
  509. {
  510.     object x = x0;
  511.     int i;
  512.     object y, l;
  513.  
  514.     if (type_of(x) != t_package) {
  515.         x = find_package(x);
  516.         if (x == Cnil)
  517.             no_package(x0);
  518.     }
  519.     if (x == keyword_package)
  520.         FEerror("Cannot use keyword package.", 0);
  521.     if (p == x)
  522.         return;
  523.     if (member_eq(x, p->p.p_uselist))
  524.         return;
  525.     for (i = 0;  i < PHTABSIZE;  i++)
  526.         for (l = x->p.p_external[i];
  527.              type_of(l) == t_cons;
  528.              l = l->c.c_cdr) {
  529.             y = find_symbol(l->c.c_car, p);
  530.             if (intern_flag && l->c.c_car != y)
  531. FEerror("Cannot use ~S~%\
  532. from ~S,~%\
  533. because ~S and ~S will cause~%\
  534. a name conflict.", 4, x, p, l->c.c_car, y);
  535.         }
  536.     p->p.p_uselist = make_cons(x, p->p.p_uselist);
  537.     x->p.p_usedbylist = make_cons(p, x->p.p_usedbylist);
  538. }
  539.  
  540. unuse_package(x0, p)
  541. object x0, p;
  542. {
  543.     object x = x0;
  544.  
  545.     if (type_of(x) != t_package) {
  546.         x = find_package(x);
  547.         if (x == Cnil)
  548.             no_package(x0);
  549.     }
  550.     delete_eq(x, &p->p.p_uselist);
  551.     delete_eq(p, &x->p.p_usedbylist);
  552. }
  553.  
  554. @(defun make_package (pack_name
  555.               &key nicknames
  556.                (use `make_cons(lisp_package, Cnil)`))
  557. @
  558.     check_type_or_string_symbol(&pack_name);
  559.     @(return `make_package(pack_name, nicknames, use)`)
  560. @)
  561.  
  562. @(defun in_package (pack_name &key nicknames (use Cnil use_sp))
  563. @
  564.     check_type_or_string_symbol(&pack_name);
  565.     if (find_package(pack_name) == Cnil && !(use_sp))
  566.         use = make_cons(lisp_package, Cnil);
  567.     @(return `in_package(pack_name, nicknames, use)`)
  568. @)
  569.  
  570. Lfind_package()
  571. {
  572.     check_arg(1);
  573.  
  574.     vs_base[0] = find_package(vs_base[0]);
  575. }
  576.  
  577. Lpackage_name()
  578. {
  579.     check_arg(1);
  580.  
  581.     check_type_package(&vs_base[0]);
  582.     vs_base[0] = vs_base[0]->p.p_name;
  583. }
  584.  
  585. Lpackage_nicknames()
  586. {
  587.     check_arg(1);
  588.  
  589.     check_type_or_symbol_string_package(&vs_base[0]);
  590.     vs_base[0] = coerce_to_package(vs_base[0]);
  591.     vs_base[0] = vs_base[0]->p.p_nicknames;
  592. }
  593.  
  594. @(defun rename_package (pack new_name &o new_nicknames)
  595. @
  596.     check_type_or_symbol_string_package(&pack);
  597.     pack = coerce_to_package(pack);
  598.     check_type_or_string_symbol(&new_name);
  599.     @(return `rename_package(pack, new_name, new_nicknames)`)
  600. @)
  601.  
  602. Lpackage_use_list()
  603. {
  604.     check_arg(1);
  605.  
  606.     check_type_or_symbol_string_package(&vs_base[0]);
  607.     vs_base[0] = coerce_to_package(vs_base[0]);
  608.     vs_base[0] = vs_base[0]->p.p_uselist;
  609. }
  610.  
  611. Lpackage_used_by_list()
  612. {
  613.     check_arg(1);
  614.  
  615.     check_type_or_symbol_string_package(&vs_base[0]);
  616.     vs_base[0] = coerce_to_package(vs_base[0]);
  617.     vs_base[0] = vs_base[0]->p.p_usedbylist;
  618. }
  619.  
  620. Lpackage_shadowing_symbols()
  621. {
  622.     check_arg(1);
  623.  
  624.     check_type_or_symbol_string_package(&vs_base[0]);
  625.     vs_base[0] = coerce_to_package(vs_base[0]);
  626.     vs_base[0] = vs_base[0]->p.p_shadowings;
  627. }
  628.  
  629. Llist_all_packages()
  630. {
  631.     struct package *p;
  632.     int i;
  633.  
  634.     check_arg(0);
  635.     for (p = pack_pointer, i = 0;  p != NULL;  p = p->p_link, i++)
  636.         vs_push((object)p);
  637.     vs_push(Cnil);
  638.     while (i-- > 0)
  639.         stack_cons();
  640. }
  641.  
  642. @(defun intern (strng &optional (p `current_package()`) &aux sym)
  643. @
  644.     check_type_string(&strng);
  645.     check_type_or_symbol_string_package(&p);
  646.     p = coerce_to_package(p);
  647.     sym = intern(strng, p);
  648.     if (intern_flag == INTERNAL)
  649.         @(return sym Kinternal)
  650.     if (intern_flag == EXTERNAL)
  651.         @(return sym Kexternal)
  652.     if (intern_flag == INHERITED)
  653.         @(return sym Kinherited)
  654.     @(return sym Cnil)
  655. @)
  656.  
  657. @(defun find_symbol (strng &optional (p `current_package()`))
  658.     object x;
  659. @
  660.     check_type_string(&strng);
  661.     check_type_or_symbol_string_package(&p);
  662.     p = coerce_to_package(p);
  663.     x = find_symbol(strng, p);
  664.     if (intern_flag == INTERNAL)
  665.         @(return x Kinternal)
  666.     if (intern_flag == EXTERNAL)
  667.         @(return x Kexternal)
  668.     if (intern_flag == INHERITED)
  669.         @(return x Kinherited)
  670.     @(return Cnil Cnil)
  671. @)
  672.  
  673. @(defun unintern (symbl &optional (p `current_package()`))
  674.     object x;
  675. @
  676.     check_type_symbol(&symbl);
  677.     check_type_or_symbol_string_package(&p);
  678.     p = coerce_to_package(p);
  679.     if (unintern(symbl, p))
  680.         @(return Ct)
  681.     else
  682.         @(return Cnil)
  683. @)
  684.  
  685. @(defun export (symbols &o (pack `current_package()`))
  686.     object l;
  687. @
  688.     check_type_or_symbol_string_package(&pack);
  689.     pack = coerce_to_package(pack);
  690. BEGIN:
  691.     switch (type_of(symbols)) {
  692.     case t_symbol:
  693.         if (symbols == Cnil)
  694.             break;
  695.         export(symbols, pack);
  696.         break;
  697.  
  698.     case t_cons:
  699.         for (l = symbols;  !endp(l);  l = l->c.c_cdr)
  700.             export(l->c.c_car, pack);
  701.         break;
  702.  
  703.     default:
  704.         check_type_symbol(&symbols);
  705.         goto BEGIN;
  706.     }
  707.     @(return Ct)
  708. @)
  709.  
  710. @(defun unexport (symbols &o (pack `current_package()`))
  711.     object l;
  712. @
  713.     check_type_or_symbol_string_package(&pack);
  714.     pack = coerce_to_package(pack);
  715. BEGIN:
  716.     switch (type_of(symbols)) {
  717.     case t_symbol:
  718.         if (symbols == Cnil)
  719.             break;
  720.         unexport(symbols, pack);
  721.         break;
  722.  
  723.     case t_cons:
  724.         for (l = symbols;  !endp(l);  l = l->c.c_cdr)
  725.             unexport(l->c.c_car, pack);
  726.         break;
  727.  
  728.     default:
  729.         check_type_symbol(&symbols);
  730.         goto BEGIN;
  731.     }
  732.     @(return Ct)
  733. @)
  734.  
  735. @(defun import (symbols &o (pack `current_package()`))
  736.     object l;
  737. @
  738.     check_type_or_symbol_string_package(&pack);
  739.     pack = coerce_to_package(pack);
  740. BEGIN:
  741.     switch (type_of(symbols)) {
  742.     case t_symbol:
  743.         if (symbols == Cnil)
  744.             break;
  745.         import(symbols, pack);
  746.         break;
  747.  
  748.     case t_cons:
  749.         for (l = symbols;  !endp(l);  l = l->c.c_cdr)
  750.             import(l->c.c_car, pack);
  751.         break;
  752.  
  753.     default:
  754.         check_type_symbol(&symbols);
  755.         goto BEGIN;
  756.     }
  757.     @(return Ct)
  758. @)
  759.  
  760. @(defun shadowing_import (symbols &o (pack `current_package()`))
  761.     object l;
  762. @
  763.     check_type_or_symbol_string_package(&pack);
  764.     pack = coerce_to_package(pack);
  765. BEGIN:
  766.     switch (type_of(symbols)) {
  767.     case t_symbol:
  768.         if (symbols == Cnil)
  769.             break;
  770.         shadowing_import(symbols, pack);
  771.         break;
  772.  
  773.     case t_cons:
  774.         for (l = symbols;  !endp(l);  l = l->c.c_cdr)
  775.             shadowing_import(l->c.c_car, pack);
  776.         break;
  777.  
  778.     default:
  779.         check_type_symbol(&symbols);
  780.         goto BEGIN;
  781.     }
  782.     @(return Ct)
  783. @)
  784.  
  785. @(defun shadow (symbols &o (pack `current_package()`))
  786.     object l;
  787. @
  788.     check_type_or_symbol_string_package(&pack);
  789.     pack = coerce_to_package(pack);
  790. BEGIN:
  791.     switch (type_of(symbols)) {
  792.     case t_symbol:
  793.         if (symbols == Cnil)
  794.             break;
  795.         shadow(symbols, pack);
  796.         break;
  797.  
  798.     case t_cons:
  799.         for (l = symbols;  !endp(l);  l = l->c.c_cdr)
  800.             shadow(l->c.c_car, pack);
  801.         break;
  802.  
  803.     default:
  804.         check_type_symbol(&symbols);
  805.         goto BEGIN;
  806.     }
  807.     @(return Ct)
  808. @)
  809.  
  810. @(defun use_package (pack &o (pa `current_package()`))
  811.     object l;
  812. @
  813.     check_type_or_symbol_string_package(&pa);
  814.     pa = coerce_to_package(pa);
  815. BEGIN:
  816.     switch (type_of(pack)) {
  817.     case t_symbol:
  818.         if (pack == Cnil)
  819.             break;
  820.  
  821.     case t_string:
  822.     case t_package:
  823.         use_package(pack, pa);
  824.         break;
  825.  
  826.     case t_cons:
  827.         for (l = pack;  !endp(l);  l = l->c.c_cdr)
  828.             use_package(l->c.c_car, pa);
  829.         break;
  830.  
  831.     default:
  832.         check_type_package(&pack);
  833.         goto BEGIN;
  834.     }
  835.     @(return Ct)
  836. @)
  837.  
  838. @(defun unuse_package (pack &o (pa `current_package()`))
  839.     object l;
  840. @
  841.     check_type_or_symbol_string_package(&pa);
  842.     pa = coerce_to_package(pa);
  843. BEGIN:
  844.     switch (type_of(pack)) {
  845.     case t_symbol:
  846.         if (pack == Cnil)
  847.             break;
  848.  
  849.     case t_string:
  850.     case t_package:
  851.         unuse_package(pack, pa);
  852.         break;
  853.  
  854.     case t_cons:
  855.         for (l = pack;  !endp(l);  l = l->c.c_cdr)
  856.             unuse_package(l->c.c_car, pa);
  857.         break;
  858.  
  859.     default:
  860.         check_type_package(&pack);
  861.         goto BEGIN;
  862.     }
  863.     @(return Ct)
  864. @)
  865.  
  866. siLpackage_internal()
  867. {
  868.     int j;
  869.  
  870.     check_arg(2);
  871.     check_type_package(&vs_base[0]);
  872.     if (type_of(vs_base[1]) != t_fixnum ||
  873.         (j = fix(vs_base[1])) < 0 || j >= PHTABSIZE)
  874.         FEerror("~S is an illgal index to a package hashtable.",
  875.             1, vs_base[1]);
  876.     vs_base[0] = vs_base[0]->p.p_internal[j];
  877.     vs_pop;
  878. }
  879.  
  880. siLpackage_external()
  881. {
  882.     int j;
  883.  
  884.     check_arg(2);
  885.     check_type_package(&vs_base[0]);
  886.     if (type_of(vs_base[1]) != t_fixnum ||
  887.         (j = fix(vs_base[1])) < 0 || j >= PHTABSIZE)
  888.         FEerror("~S is an illegal index to a package hashtable.",
  889.             1, vs_base[1]);
  890.     vs_base[0] = vs_base[0]->p.p_external[j];
  891.     vs_pop;
  892. }
  893.  
  894. no_package(n)
  895. object n;
  896. {
  897.     FEerror("There is no package with the name ~A.", 1, n);
  898. }
  899.  
  900. package_already(n)
  901. object n;
  902. {
  903.     FEerror("A package with the name ~A already exists.", 1, n);
  904. }
  905.  
  906. init_package()
  907. {
  908.  
  909.     lisp_package
  910.     = make_package(make_simple_string("LISP"),
  911.                Cnil, Cnil);
  912.     user_package
  913.     = make_package(make_simple_string("USER"),
  914.                Cnil,
  915.                make_cons(lisp_package, Cnil));
  916.     keyword_package
  917.     = make_package(make_simple_string("KEYWORD"),
  918.                Cnil, Cnil);
  919.     system_package
  920.     = make_package(make_simple_string("SYSTEM"),
  921.                make_cons(make_simple_string("SI"),
  922.                      make_cons(make_simple_string("SYS"),
  923.                        Cnil)),
  924.                make_cons(lisp_package, Cnil));
  925.  
  926.     /*  There is no need to enter a package as a mark origin.  */
  927.  
  928.     Vpackage = make_special("*PACKAGE*", lisp_package);
  929.  
  930.     Kinternal = make_keyword("INTERNAL");
  931.     Kexternal = make_keyword("EXTERNAL");
  932.     Kinherited = make_keyword("INHERITED");
  933.     Knicknames = make_keyword("NICKNAMES");
  934.     Kuse = make_keyword("USE");
  935.  
  936.     uninterned_list = Cnil;
  937.     enter_mark_origin(&uninterned_list);
  938. }
  939.  
  940. init_package_function()
  941. {
  942.     make_function("MAKE-PACKAGE", Lmake_package);
  943.     make_function("IN-PACKAGE", Lin_package);
  944.     make_function("FIND-PACKAGE", Lfind_package);
  945.     make_function("PACKAGE-NAME", Lpackage_name);
  946.     make_function("PACKAGE-NICKNAMES", Lpackage_nicknames);
  947.     make_function("RENAME-PACKAGE", Lrename_package);
  948.     make_function("PACKAGE-USE-LIST", Lpackage_use_list);
  949.     make_function("PACKAGE-USED-BY-LIST", Lpackage_used_by_list);
  950.     make_function("PACKAGE-SHADOWING-SYMBOLS",
  951.               Lpackage_shadowing_symbols);
  952.     make_function("LIST-ALL-PACKAGES", Llist_all_packages);
  953.     make_function("INTERN", Lintern);
  954.     make_function("FIND-SYMBOL", Lfind_symbol);
  955.     make_function("UNINTERN", Lunintern);
  956.     make_function("EXPORT", Lexport);
  957.     make_function("UNEXPORT", Lunexport);
  958.     make_function("IMPORT", Limport);
  959.     make_function("SHADOWING-IMPORT", Lshadowing_import);
  960.     make_function("SHADOW", Lshadow);
  961.     make_function("USE-PACKAGE", Luse_package);
  962.     make_function("UNUSE-PACKAGE", Lunuse_package);
  963.  
  964.     make_si_function("PACKAGE-INTERNAL", siLpackage_internal);
  965.     make_si_function("PACKAGE-EXTERNAL", siLpackage_external);
  966. }
  967.